Celestin Apprentice 7/Apprentice-Release7.iso/Environments/Clean 1.2.4/StdEnv/StdList.icl

Modula Implementation | 1997-04-02 | 9.3 KB | 410 lines | [TEXT/3PRM]

implementation module StdList

// ****************************************************************************************
//    Concurrent Clean Standard Library Module Version 1.1
//    Copyright 1995 University of Nijmegen
// ****************************************************************************************

import    StdClass, StdMisc, StdEnum, StdInt, StdChar, StdBool, StdArray, StdString

// ****************************************************************************************
//    Instances of overloaded functions:
// ****************************************************************************************

instance ==     [a] | Eq a
    where
    (==) :: ![a]    ![a]    ->    Bool | Eq a
    (==) [] []
        = True
    (==) [] _
        = False
    (==) [_:_] []
        = False
    (==) [a:as] [b:bs]
        | a == b
            = as == bs
        // otherwise
            = False

instance < [a] | Ord a
    where
    (<) :: ![a]    ![a] ->    Bool | Ord a
    (<) []      []
        = False
    (<) [] _
        = True
    (<) [_:_] []
        = False
    (<) [a:as] [b:bs]
        | a < b
            = True
        | a > b
            = False
        // otherwise
            = as < bs

instance length []
    where
    length ::![a] -> Int
    length xs = acclen 0 xs
    where
        acclen n [x:xs] = acclen (inc n) xs
        acclen n []     = n

instance % [a]
    where
    (%) :: ![a] !(!Int,!Int) -> [a]
    (%) list (frm,to) = take (to - frm + 1) (drop frm list)


instance toString     [x] | toChar x
    where
    toString::![x] -> {#Char} | toChar x
    toString xs = ltosacc xs ""
    where
        ltosacc [h:t] acc = ltosacc t (acc +++ toString (toChar h))
        ltosacc []      acc = acc

instance fromString [x] | fromChar x
    where
    fromString::!{#Char} -> [x] | fromChar x
    fromString s = stolacc s (size s - 1) []
    where
        stolacc :: !String !Int u:[a] -> u:[a] | fromChar a
        stolacc s i acc
            | i >= 0
                = stolacc s (dec i) [fromChar (s.[i]) : acc]
            // otherwise
                = acc

// ****************************************************************************************
// standard operators
// ****************************************************************************************

(!!) infixl 9::![.a] Int -> .a
(!!) [] _
    = abort "Subscript error in !,index too large"
(!!) list i
    =    index list i
    where
        index ::![.a] !Int -> .a
        index [hd:tl] 0
            = hd
        index [hd:tl] n
            = index tl (n - 1)
        index [] _
            = abort "Subscript error in !,index too large"

(++) infixr 5::![.a] u:[.a] -> u:[.a]
(++) [hd:tl]    list    = [hd:tl ++ list]
(++) nil         list    = list

flatten::![[.a]] -> [.a]
flatten [h:t]    = h ++ flatten t
flatten []        = []

isEmpty::![.a] -> Bool
isEmpty    []
    =    True
isEmpty    _
    =    False

// ****************************************************************************************
// standard functions
// ****************************************************************************************

drop::Int !u:[.a] -> u:[.a]
drop n cons=:[a:x]    | n>0    = drop (n - 1) x
                            = cons
drop n []                    = []

dropLast::![.a] -> [.a] // include functions like this?? and what about dropUntil ??
dropLast [a]    = []
dropLast [a:b]    = [a:dropLast b]
dropLast []        = abort "dropLast of []"

dropWhile :: (a -> .Bool) !u:[a] -> u:[a]
dropWhile f cons=:[a:x]    | f a    = dropWhile f x
                                = cons
dropWhile f []                    = []

filter::(a -> .Bool) !.[a] -> .[a]
filter f [a:x]    | f a    = [a:filter f x]
                        = filter f x
filter f []                = []

// foldl::(.a -> .(.b -> .a)) .a ![.b] -> .a
foldl op r l
    :==    foldl r l
    where
        foldl r []        = r
        foldl r [a:x]    = foldl (op r a) x

// foldr::(.a -> .(.b -> .b)) .b ![.a] -> .b
foldr op r l
    :== foldr r l
    where
        foldr r []        = r
        foldr r [a:x]    = op a (foldr r x)

hd::![.a] -> .a
hd [a:x]    = a
hd []        = abort "hd of []"

indexList::![.a] -> [Int]
indexList x = f 0 x
where
    f::!Int ![.a] -> [Int]
    f n [a:x]    = [n:f (n+1) x]
    f n []        = []

insert :: (a a -> .Bool) a !u:[a] -> u:[a];
insert r x ls=:[y : ys]
| r x y            =     [x : ls]
                =    [y : insert r x ys]
insert _ x []     =     [x]

iterate::(a -> a) a -> .[a]
iterate f x    = [x:iterate f (f x)]

last::![.a] -> .a
last [a]    = a
last [a:tl]    = last tl
last []        = abort "last of []"

map::(.a -> .b) ![.a] -> [.b]
map f [a:x]    = [f a:map f x]
map f []    = []

remove :: !Int !u:[.a] -> u:[.a]
remove 0 [y : ys]    =     ys
remove n [y : ys]    =    [y : remove (n-1) ys]
remove n []            =     []

repeatn :: .Int a -> .[a]
repeatn n x    = take n (repeat x)

repeat:: a -> [a]
repeat x =     cons
where
    cons = [x:cons]

reverse::![.a] -> [.a]
reverse list = reverse_ list []
where
    reverse_::![.a] u:[.a] -> u:[.a]
    reverse_ [hd:tl] list    = reverse_ tl [hd:list]
    reverse_ [] list        = list

scan:: (a -> .(.b -> a)) a ![.b] -> .[a]
scan op r [a:x]    = [r:scan op (op r a) x]
scan op r []    = [r]

span :: (a -> .Bool) !u:[a] -> (.[a],u:[a])
span p list=:[x:xs]
    | p x
        = ([x:ys],zs)
         with    (ys,zs) = span p xs
     // otherwise
        = ([],list)
span p []
    =    ([], [])

splitAt :: !Int u:[.a] -> ([.a],u:[.a])
splitAt 0     xs    =    ([],xs)
splitAt _     []    =    ([],[])
splitAt n [x:xs]    =    ([x:xs`],xs``)
where
    (xs`,xs``) = splitAt (n-1) xs

take::!Int [.a] -> [.a]
take 0 _        = []
take n [a:x]    = [a:take (dec n) x]
take n []        = []

takeWhile::(a -> .Bool) !.[a] -> .[a]
takeWhile f [a:x] | f a    = [a:takeWhile f x]
                        = []
takeWhile f []            = []

tl::!u:[.a] -> u:[.a]
tl [a:x]    = x
tl []        = abort "tl of []"

unzip::![(.a,.b)] -> ([.a],[.b])
unzip []    =     ([], [])
unzip [(x,y) : xys] = ([x : xs],[y : ys])
where
    (xs,ys) = unzip xys

zip2::![.a] [.b] -> [(.a,.b)]
zip2 [a:as] [b:bs]    = [(a,b):zip2 as bs]
zip2 as bs            = []

zip::!(![.a],[.b]) -> [(.a,.b)]
zip (x,y) = zip2 x y

diag3:: !.[a] .[b] .[c]-> [.(a,b,c)]
diag3 xs ys zs = [ (x,y,z) \\ ((x,y),z) <- diag2 (diag2 xs  ys) zs ]

//    diagonalisation: basic idea (for infinite lists):
//
//    diag2 xs ys = flatten [ dig2n n xs ys \\ n <- [1..] ]
//    where dig2n n xs ys = [ (a,b) \\ a <- reverse (take n xs) & b <- take n ys ]
//
//    in the definition below this idea is adapted in order to deal with finite lists too

diag2:: !.[a] .[b] -> [.(a,b)]
diag2 [] ys = []
diag2 xs [] = []
diag2 xs ys = [ (ae,be) \\ (a,b) <- takeall xs [] ys [], ae <- a & be <- b ]
where
    takeall xin xout yin yout
    | morex&&morey    = [(nxout,   nyout) : takeall nxin nxout nyin     nyout ]
    | morey            = [( xout,tl nyout) : takeall  xin  xout nyin (tl nyout)]
    | morex            = [(nxout,    yout) : takeall nxin nxout  yin      yout ]
    // otherwise
                    = shift xout yout
    where
        (morex,nxin,nxout) = takexnext xin xout
        (morey,nyin,nyout) = takeynext yin yout

        takexnext [x:xs] accu    = (True, xs,[x:accu])
        takexnext []     accu     = (False,[],accu)

        takeynext [y:ys] accu    = (True, ys,accu++[y])
        takeynext []     accu    = (False,[],accu)

        shift xout [_:ys]    = [(xout,ys): shift xout ys]
        shift _    []         = []

// ****************************************************************************************
// Boolean list
// ****************************************************************************************

and::![.Bool] -> Bool
and []
    =    True
and [b : tl]
    | b
        =    and tl
    // otherwise
        =    False

or::![.Bool] -> Bool
or []
    =    False
or [b : tl]
    | b
        =    True
    // otherwise
        =    or tl

any::(.a -> .Bool) ![.a] -> Bool
any p q    = or (map p q)

all::(.a -> .Bool) ![.a] -> Bool
all p q    = and (map p q)

maxList::!.[a] -> a | Ord a
maxList [a:x] = max1 a x
where
    max1:: a !.[a] -> a | Ord a
    max1 m [hd:tl]
        | hd<m        = max1 m tl
        // otherwise
                    = max1 hd tl
    max1 m []        = m
maxList []    = abort "max of empty list"


minList::!.[a] -> a | Ord a
minList [a:x]    = min1 a x
where
    min1:: a !.[a] -> a | Ord a
    min1 m [hd:tl]
        | m<hd        = min1 m tl
        // otherwise
                    = min1 hd tl
    min1 m []        = m
minList []        = abort "min of empty list"

sort::!.[a] -> .[a] | Ord a
sort [e:es]    = insert e (sort es)
where
    insert::a !u:[a] -> u:[a] | Ord a
    insert a list=:[b:x]
        | a<b        = [a:list]
        // otherwise
                    = [b:insert a x]
    insert a []    = [a]
sort []        = []

merge :: !u:[a] !u:[a] -> u:[a] | Ord a
merge []  y            = y
merge f=:[x:xs] []    = f
merge f=:[x:xs] s=:[y:ys]
    | x<y                = [x:merge xs s]
    // otherwise
                        = [y:merge f ys]

// ****************************************************************************************
// On Ord
// ****************************************************************************************

isMember::a !.[a] -> Bool | Eq a
isMember x [hd:tl]
    | hd==x        = True
    // otherwise
                = isMember x tl
isMember x []    = False

removeDup :: !.[a] -> .[a] | Eq a
removeDup [x:xs] = [x:removeDup (filter ((<>) x) xs)]
removeDup _      = []

removeMembers::u:[a] .[a] -> u:[a] | Eq a
removeMembers x []        = x
removeMembers x [b:y]    = removeMembers (remove b x) y
where
    remove:: a u:[a] -> u:[a] | Eq a
    remove e [a:as]
        | a==e        = as
        // otherwise
                    = [a:remove e as]
    remove e []        = []

limit::!.[a] -> a | Eq a
limit [a:cons=:[b:x]]
    | a==b        = a
    // otherwise
                = limit cons
limit other        = abort "incorrect use of limit"

// ****************************************************************************************
// On PlusMin
// ****************************************************************************************

sum:: !.[a] -> a |  + , zero  a
sum xs = accsum zero xs
where
    accsum n [x:xs] = accsum (n + x) xs
    accsum n []     = n

// ****************************************************************************************
// On Arith
// ****************************************************************************************

prod:: !.[a] -> a | * , one  a
prod xs = accprod one xs
where
    accprod n [x:xs] = accprod (n * x) xs
    accprod n []     = n

avg:: !.[a] -> a | / , IncDec a
avg [] = abort "avg called with empty list"
avg x  = accavg zero zero x
where
    accavg n nelem [x:xs] = accavg (n + x) (inc nelem) xs
    accavg n nelem []     = n / nelem